home *** CD-ROM | disk | FTP | other *** search
/ Sprite 1984 - 1993 / Sprite 1984 - 1993.iso / lib / tcl / demos / mkCanvText.tcl < prev    next >
Text File  |  1992-08-13  |  4KB  |  111 lines
  1. # mkCanvText w
  2. #
  3. # Create a top-level window containing a canvas displaying a text
  4. # string and allowing the string to be edited and re-anchored.
  5. #
  6. # Arguments:
  7. #    w -    Name to use for new top-level window.
  8.  
  9. proc mkCanvText {{w .ctext}} {
  10.     catch {destroy $w}
  11.     toplevel $w
  12.     dpos $w
  13.     wm title $w "Canvas Text Demonstration"
  14.     wm iconname $w "Text"
  15.     set c $w.c
  16.  
  17.     frame $w.frame1 -relief raised -bd 2
  18.     canvas $c -relief raised -width 500 -height 400
  19.     button $w.ok -text "OK" -command "destroy $w"
  20.     pack append $w $w.frame1 {top fill} $w.c {expand fill} \
  21.         $w.ok {bottom pady 10 frame center}
  22.     message $w.frame1.m -font -Adobe-Times-Medium-R-Normal-*-180-* -aspect 300 \
  23.         -text "This window displays a string of text to demonstrate the text facilities of canvas widgets.  You can point, click, and type.  You can also select and then delete with Control-d.  You can copy the selection with Control-v.  You can click in the boxes to adjust the position of the text relative to its positioning point or change its justification."
  24.     pack append $w.frame1 $w.frame1.m {frame center}
  25.  
  26.     set font -Adobe-helvetica-medium-r-*-240-*
  27.  
  28.     $c create rectangle 245 195 255 205 -outline black -fill red
  29.  
  30.     # First, create the text item and give it bindings so it can be edited.
  31.     
  32.     $c addtag text withtag [$c create text 250 200 -text "This is just a string of text to demonstrate the text facilities of canvas widgets. You can point, click, and type.  You can also select and then delete with Control-d." -width 440 -anchor n -font $font -justify left]
  33.     $c bind text <1> "textB1Press $c %x %y"
  34.     $c bind text <B1-Motion> "textB1Move $c %x %y"
  35.     $c bind text <Shift-1> "$c select adjust current @%x,%y"
  36.     $c bind text <Shift-B1-Motion> "textB1Move $c %x %y"
  37.     $c bind text <KeyPress> "$c insert text cursor %A"
  38.     $c bind text <Shift-KeyPress> "$c insert text cursor %A"
  39.     $c bind text <Control-h> "textBs $c"
  40.     $c bind text <Delete> "textBs $c"
  41.     $c bind text <Control-d> "$c dchars text sel.first sel.last"
  42.     $c bind text <Control-v> "$c insert text cursor \[selection get\]"
  43.  
  44.     # Next, create some items that allow the text's anchor position
  45.     # to be edited.
  46.  
  47.     set x 50
  48.     set y 50
  49.     set color LightSkyBlue1
  50.     mkTextConfig $c $x $y -anchor se $color
  51.     mkTextConfig $c [expr $x+30] [expr $y] -anchor s $color
  52.     mkTextConfig $c [expr $x+60] [expr $y] -anchor sw $color
  53.     mkTextConfig $c [expr $x] [expr $y+30] -anchor e $color
  54.     mkTextConfig $c [expr $x+30] [expr $y+30] -anchor center $color
  55.     mkTextConfig $c [expr $x+60] [expr $y+30] -anchor w $color
  56.     mkTextConfig $c [expr $x] [expr $y+60] -anchor ne $color
  57.     mkTextConfig $c [expr $x+30] [expr $y+60] -anchor n $color
  58.     mkTextConfig $c [expr $x+60] [expr $y+60] -anchor nw $color
  59.     set item [$c create rect [expr $x+40] [expr $y+40] [expr $x+50] [expr $y+50] \
  60.         -outline black -fill red]
  61.     $c bind $item <1> "$c itemconf text -anchor center"
  62.     $c create text [expr $x+45] [expr $y-5] -text {Text Position} -anchor s \
  63.         -font -Adobe-times-medium-r-normal--*-240-* -fill brown
  64.  
  65.     # Lastly, create some items that allow the text's justification to be
  66.     # changed.
  67.     
  68.     set x 350
  69.     set y 50
  70.     set color SeaGreen2
  71.     mkTextConfig $c $x $y -justify left $color
  72.     mkTextConfig $c [expr $x+30] [expr $y] -justify center $color
  73.     mkTextConfig $c [expr $x+60] [expr $y] -justify right $color
  74.     $c create text [expr $x+45] [expr $y-5] -text {Justification} -anchor s \
  75.         -font -Adobe-times-medium-r-normal--*-240-* -fill brown
  76.  
  77.     $c bind config <Enter> "textEnter $c"
  78.     $c bind config <Leave> "$c itemconf current -fill \$textConfigFill"
  79. }
  80.  
  81. proc mkTextConfig {w x y option value color} {
  82.     set item [$w create rect [expr $x] [expr $y] [expr $x+30] [expr $y+30] \
  83.         -outline black -fill $color -width 1]
  84.     $w bind $item <1> "$w itemconf text $option $value"
  85.     $w addtag config withtag $item
  86. }
  87.  
  88. set textConfigFill {}
  89.  
  90. proc textEnter {w} {
  91.     global textConfigFill
  92.     set textConfigFill [lindex [$w itemconfig current -fill] 4]
  93.     $w itemconfig current -fill black
  94. }
  95.  
  96. proc textB1Press {w x y} {
  97.     $w cursor current @$x,$y
  98.     $w focus current
  99.     focus $w
  100.     $w select from current @$x,$y
  101. }
  102.  
  103. proc textB1Move {w x y} {
  104.     $w select to current @$x,$y
  105. }
  106.  
  107. proc textBs {w} {
  108.     set char [expr {[$w index text cursor] - 1}]
  109.     if {$char >= 0} {$w dchar text $char}
  110. }
  111.